How and why?
Mathematica Techniques
By Allan Hayes

FunctionalFindMinimum; fast sums of squares; the general form of Inner; frames and backgrounds for text; intersections of lists; evaluation of conditions on the right of rules; evaluation in place; the Graphics3D option PolygonIntersections.

FunctionalFindMinimum

To use FindMinimum to find the minimum of an expression in x,y,... we need to supply both the variables and their initial values. The function FunctionalFindMinimum below lets us use functions and only the initial  values.  We have to return the variable values giving the minimum  rather than replacement rules for them.

FindMinimum[(x^4)+3(x^2)y+5(y^2)+x+y,{x,0.1},{y,0.2}]

f[x_,y_] := (x^4)+3(x^2)y+5(y^2)+x+y;
ff= Function[{x,y}, (x^4)+3(x^2)y+5(y^2)+x+y];
fff = ((#)^4)+3((#)^2)#2+5((#2)^2)+#+#2&;

Give the new function the attribute HoldAll, consistent with FindMinimum.

SetAttributes[FunctionalFindMinimum, HoldAll]

FunctionalFindMinimum[f_,starts___List]:= 
FindMinimum[f@@#,Evaluate[Sequence@@Transpose[{#,{starts}}]]]&[Unique[x]&/@{starts}]/.HoldPattern[_->n_ ]:>n

Programming note:
Notice the use of Unique[x]/@{starts}to generate the required number of new variables.

Check

FunctionalFindMinimum[f,0.1,0.2]
FunctionalFindMinimum[ff,{0.1, 0.0},{0.2,.3}] 
FunctionalFindMinimum[fff,{0.1, 0.0},{0.2,.3}]

Fast sums of squares

Here are six ways of summing the squares of members of a list.

f[1][x_]:=Sum[x[[i]]^2,{i,Length[x]}];
f[2][x_]:= Plus@@x^2;
f[3][x_] := x.x;
f[4]= Compile[ {{x,_Real,1}},x.x];
f[5]= #.#&;

Time the functions on the input

dd= Table[Random[],{500},{Random[Integer, {0,1000}]}];

{#,f[#]/@dd//Timing//First}&/@Range[5]

So f[5] is quickest, not the compiled function.

The general form of Inner

It is always a good idea to look up functions in the Help Browser check on their more  general forms.

v1 = {a,b,c};
v2 = {A,B, C};

Times@@(v1-v2)

Inner[Subtract,v1,v2,Times]

The Inner  form looks cumbersome, but it is faster, certainly for higher dimensions:

v1 = Table[Random, {100}];
v2 = Table[Random, {100}];

Do[Times@@(v1-v2),{100}]//Timing
Do[Inner[Subtract,v1,v2,Times],
{100}]//Timing

Here is nice application that was sent to MathGroup by Kenneth Levasseur:
If X={X1, X2, ...,Xn} is a list of sets, a test to determine whether a ={a1,a2,...,an} is in the cartesian
product of the sets is Inner[MemberQ[#1,#2]&,X,a,And] 
Check:

X = {{1,3,6},{3,7}};

Inner[MemberQ[#1,#2]&,X,{1,4},And]

Inner[MemberQ[#1,#2]&,X,{1,3},And]

Frames and Backgrounds for text

- in a new text cell, type THE 
- select THE; use  menu > Edit > Expression Input > Add Frame (this gives  THE )
- by typing inside the frame make

THE
EXAMPLE

- put a frame round THE as before; select this frame (not just the text); menu > Format > Background Color > Magenta
- select EXAMPLE; menu > Format > (Text Color > Red and Background Color > Yellow)
- select the outer frame; menu > Format > Background Color > Cyan
- select the outer frame; menu Format > Option Inspector > [Lookup ][FrameBoxOptions]> set BoxFrame ⟶ 4 > [Apply]
- select the outer frame;  menu > Format > Text Color > Blue (this colors the frame blue)

THE
EXAMPLE

Intersections of Lists

lst1 = {a,b,a,a,b,c};
lst2 = {b,a,b,a,b};

Dealing with lists it might seem reasonable to think of Intersection[lst1, lst2] as {a,a,b,b}. However we get

Intersection[lst1,lst2]

Fred Simons observed the following

Flatten[List@@PolynomialGCD[Times@@lst1, Times@@lst2]/.x_^y_ :>Table[x,{y}]]

To get this to work with more general entries we need to stop them multiplying together. This is conveniently done by wrapping each list element in Hold, which is removed after the calculation. Also we flatten only to level 1 in case some of the elements are lists.

listIntersection1[l1_,l2_]:= 
Flatten[List@@PolynomialGCD[Times@@Map[Hold,l1],Times@@Map[Hold,l2]]/.Power[x_,n_]:>Table[x,{n}],1]//ReleaseHold

listIntersection1[{1,{1,2},1,1,{1,2}, k},{{1,2},1,{1,2},1,{1,2}}]

But Intersection works with any number and kinds of entries (it returns the input unchanged unless there is at least one entry, and each entry is a a normal expressions (that is, with full form h[e1,e2, ..]), and all the heads of the entries are the same).

We can reflect this as follows (but more work would be needed to get the warning messages).

Clear[listIntersection];
listIntersection[dat:(h_[__] ..)]:= 
h@@(Flatten[List@@PolynomialGCD@@Times@@@Map[Hold,{dat},{2}]/.(x_^n_):>Table[x,{n}],1]//ReleaseHold)
listIntersection[dat:(h_[___] ..)]:= h[];

Programming note

1. dat:(h_[__] ..) matches a non empty sequence named dat of non-empty normal expressions, all with the same head;
dat:(h_[___] ..)  allows some members of the sequence to be empty
2.  We have to separate out the cases when empty entries are allowed since do not evaluate properly otherwise.

Check

listIntersection[h[1,{1,2},1,1,{1,2}, k],h[{1,2},1,{1,2},1,{1,2}]]

listIntersection[h[],h[1,2]]

{listIntersection[h[],k[]],listIntersection[], listIntersection[p,h[1]]}

Evaluation of conditions on the right of rules

Let's try to replace 2+3 in Hold[2+3] with  Hold[f[5]]

Hold[2+3]/.x_Plus ->f[x]

The catch is that x_Plus matches 2+3, which is passed to x in  f[x], giving f[2+3] ,which then replaces 2+3 in Hold[2+3] without any further evaluation.

The fact that we have used Rule (->) and not RuleDelayed (:>) is  irrelevant: they only prescribe whether or not the right side of the rule is evaluated before any replacement starts. Thus

f=g; 
Hold[2+3]/.x_Plus ->f[x]
Hold[2+3]/.x_Plus :>f[x]
Clear[f]

We could map Evaluate:

MapAt[Evaluate, Hold[f[2+3]],{{1}}]

But this does not work with  Hold[Hold[2+3]]

MapAt[Evaluate, Hold[Hold[f[2+3]]],{{1,1}}]

This is a serious problem, since many system functions have holding attributes. Several ways are available to deal with it: here is a particularly simple and widely applicable way

Hold[Hold[2+3]]/.x_Plus :> RuleCondition[f[x],True] (*1*)

The crucial point is that, after 2+3 has replaced x in f[x], because the test is True,  RuleCondition[f[2+3], True]  evaluates f[2+3] to f[5], and then  2+3 in Hold[Hold[2+3]] is replaced with f[5].
The technique can be used with other tests than True:

Hold[2+2, 3+4]/.x_Plus :> RuleCondition[f[x], x<5]

In fact, with no test (which is equivalent to using the test True)

Hold[Hold[2+3]]/.x_Plus :> RuleCondition[f[x]]

RuleCondition is an internal function, so not likely to be familiar  - it is, just, documented  (but see the caution at the end of this section):

??RuleCondition

How might we find it? It is introduced during the evaluation of conditions on the right. For example, if we trace the evaluation of

Hold[2+3]/.x_Plus:>f[x]/;True  (*2*)

with

TracePrint[Hold[2+3]/.x_Plus:>f[x]/;True]

then we find that Condition[f[2+3],True] becomes

RuleCondition[$ConditionHold[$ConditionHold[f[2+3]]],True]

This is like  (*1*) above except for the double wrapping of f[2+3] in $ConditionHold. In both (*1*) and (*2*), 2+3 matches x_ and replaces x in f[x]. But, whereas in (*1*), RuleCondition[f[2+3],True] evaluates to f[5], which then replaces 2+3 in Hold[2+3]; in (*2*) the $ConditionHold wrapping, prevents the  evaluation of f[2+3] (the double wrapping will prevent up-values evaluating) and then the unwrapped, unevaluated f[2+3] replaces 2+3  in Hold[2+3].

If we want to avoid using RuleCondition explicitly, the following works

Hold[2+3]/.x_Plus:>Block[{},f[x]/;True] (*3*)

It works because the presence of the condition f[x]/;True causes Block[..] to evaluate to RuleCondition[f[2+3], True]. Things then proceed as in (*1*).

I found the above use of RuleCondition from analyzing the Trott-Strzebonski technique using With (which I learned from Robby Villegas' talk at the 1999 Developer Conference: http://library.wolfram.com/conferences/devconf99/villegas/UnevaluatedExpressions.nb). Here it is:

Hold[2+3]/.x_Plus:>With[{p=x},f[p]/;True] (*4*)

The mechanism is different from that of (*3*): the presence of the condition f[x]/;True causes With[{p=x}, f[p]/;True] to evaluate, but in this case the condition becomes RuleCondition[$ConditionHold[$ConditionHold[f[p]]], True]. But then,  p = x becomes first p = 2+3,then  p = 5; then the p in f[p] is directly replaced by 5, circumventing the holding by $ConditionHold.
The following failed variant does not allow the evaluation of 2+3  on the right of  p:=2+3.

Hold[2+3]/.x_Plus:>With[{p:=x},f[p]/;True]

The different holding characteristics of the methods show up in the following.
It seems that the With method is the most flexible.

f[x_]= x^2;
{Hold[2+3]/.x_Plus:>With[{p=x},f[p]/;True],
Hold[2+3]/.x_Plus:>With[{p= f[x]},p/;True],
   Hold[2+3]/.x_Plus:>Block[{},f[x]/;True],
   Hold[2+3]/.x_Plus:>RuleCondition[f[x]]}

Clear[f];

Speed: in the following the RuleCondition method is twice as quick as the With method.

{Do[Hold[2+3]/.x_Plus :> RuleCondition[x,True],{5000}]//Timing//First,
Do[Hold[2+3]/.x_Plus :>Block[{}, x/;True],{5000}]//Timing//First,
Do[Hold[2+3]/.x_Plus :>With[{p=x}, p/;True],{5000}]//Timing//First}

Caution: Since RuleCondition is an internal function some caution should be exercised in using it in "permanent" code. It seems convenient enough to be upgraded to a regular built in function. The use of Condition with Block and With are documented in the Help Browser but no indications of the working  of these features are given.

Evaluation in place

We can use the above techniques for evaluating in place, but there are problems: suppose that we want to evaluate both occurrences of 2+3 in expr (below) to 5. We get

expr=Hold[2+3+Hold[2+3]];
expr/.x_Plus:>RuleCondition[x]

Using ReplaceRepeated (//.) instead of ReplaceAll(/.)does not succeed either

expr//.x_Plus:>RuleCondition[x]

This fails because the second attempt to use the rule still finds 5+Hold[2+3]. 
We can work round this problem

MapAt[f, expr, Position[expr,_Plus]]

%//.f[x_]:> RuleCondition[x]

But here is a different approach, based on specifying parts by position rather than pattern.

EvaluateAt[expr_,pos_, f_:Identity] :=
Module[{pos1},(*normalize pos*)
pos1=Switch[pos,_Integer,{{pos}},{__Integer},{pos},_,pos];
Fold[ReplacePart[#1, Extract[#1,#2, f], #2]&,expr,Reverse[Sort[pos1]]]
]

EvaluateAt[expr, Position[expr,_Plus]]

EvaluateAt[expr, 1]

EvaluateAt[expr, {1,3,1}, #^2&]

Programming note

1. Reverse is used in Reverse[Sort[pos]] to arranges the position lists in decreasing length so that the later positions still refer to the same part of the modified expression
2. Fold is used so that later replacements replace with parts of the previously modified expression, not parts of the original expression.

The Graphics3D option PolygonIntersections

The option PolygonIntersections does much more than replace polygons with non-intersecting triangles. My main interest here is that it "fixes" polygon colors:

If gr is a Graphics3D object and gr1 is the output from Show[gr, PolygonIntersections -> False], then  Show[gr1, Lighting->False] displays like Show[gr]; except that gr1 has no options, so contributions from Epilog, Prolog, FaceGrids, PlotRange,ViewPoint ... are lost. This loss can be corrected by using  Show[gr1, Lighting->False, AbsoluteOptions[gr]]

This "fixing of colors" (they are seen with Lighting->False]) can be used to:
1. combine self and reflected color (Hartmut Wolf showed me how to use it for this)
2. stop distant viewpoints making colors uniform
However there are some limitations on its use.  I'll explore both the uses and the limitations.

The details are rather complicated (you may prefer to return to the following after looking at the examples)
• In constructing gr1, objects are truncated at the bounding box (this is more than clipping the display - the actual objects are cut to size); the faces and edges of the truncated polygons and cuboids are replaced by polygons and lines, then the polygons are replaced by a collection of non-intersecting triangles and the edges of the triangles are prevented from displaying by using EdgeForm[]. Because of the truncation and triangulation the calculated plot ranges for gr1 and gr2 can be different. One extra feature - which may be a bug - is that  points that are within the bounding box but are hidden by other objects are discarded.
• The faces of the triangles in  gr2 are colored with directives of the form FaceForm[SurfaceColor[RGBColor[...]] so that with Lighting ->False they are colored as in Show[gr].  However, any two-sided coloring of polygons in gr, by FaceForm[frontface, backface],  is lost.

Examples

Meshless red ball with reflected lighting (shaded)  on self colored carpet

The ball: use Lighting->False and  SurfaceColor[Hue[0] to get the shading.

<<Graphics`Shapes`

shadedBall = 
Show[Graphics3D[{
	EdgeForm[], SurfaceColor[Hue[0]], 
	Sphere[1, 25, 25]}, 
	LightSources -> {{{1, 0, 1}, GrayLevel[1]}},
	FaceGrids -> {{-1,0,0},{0,1,0}}
 ]];

Fix  the colors. The face grids, given by an option, will be lost, and Show does not give a  display here, it simply outputs a modified object.

fixedBall=Show[shadedBall,PolygonIntersections->False];

The carpet:

carpet = 
ParametricPlot3D[
	{x, y, -1, {EdgeForm[], Hue[Random[], 0.6, 1]}}, 
 	{x, -2, 2}, {y, -2, 2}, 
 	PlotRange -> {-1, 2}, Lighting -> False
 ];

Show the ball on the carpet, and restore the face grids with Options[shadedBall].

ballOnCarpet = 
Show[fixedBall, carpet, Lighting -> False,
Options[shadedBall]
];

Self-colored (unshaded), meshed red ball inside tetrahedron with reflected lighting

To get a uniformly bright unshaded ball with mesh to give a 3D effect, use Hue[0] and Lighting ->False.

unshadedBall= 
Show[Graphics3D[{Hue[0],Sphere[.85,25,25]}], Lighting->False];

The tetrahedron with reflected lighting:

<<Graphics`Polyhedra`

tet=Show[Polyhedron[Tetrahedron]];

Fix the colors

fixedtet = Show[tet, PolygonIntersections -> False];

Put the ball inside the tetrahedron

Show[fixedtet, unshadedBall, 
	Lighting -> False, Boxed -> False];

Keeping colors with distant viewpoint

globe = 
Show[Graphics3D[{EdgeForm[], Sphere[1, 25, 25]}], 
    Boxed -> False];

A distant viewpoint gives uniform coloring

vp = AbsoluteOptions[globe, ViewPoint][[1,2]];
Show[globe,ViewPoint-> 8 vp];

Try to keep the original colors,fix the colors with the original view point and display this with the distant view point.

fixedGlobe= Show[globe,PolygonIntersections->False];

Show[fixedGlobe, 
Lighting->False,ViewPoint->8 vp,Boxed->False];

Pitfalls

The irregular edge that appeared in the last image was an indication that the procedure might be risky. Lets push our luck a little:

Take a viewpoint close to the sphere.

globe2 = Show[globe, ViewPoint -> .28vp];

Fix the colors:

fixedGlobe2= Show[globe2, PolygonIntersections->False];

Use a more distant viewpoint - simply let the default viewpoint be used.

Show[fixedGlobe2, Lighting->False];

The trouble stems from the lighting model used - a subject for a later column. We are seeing parts of the ball that were not originally seen and for which the lighting model was not intended.

It looks worse from some other view points.

Show[fixedGlobe2, ViewPoint -> {3,0,0}, Lighting ->False];

We can try using different light sources. I found this tricky - the following setting avoids the  abrupt color changes but it is by no means ideal.

lights={
{{1.,0.,1},RGBColor[.7,0,0]},{{1.,1.,1},RGBColor[0,.7,0]},{{0.,1.,1},RGBColor[0,0,.7]},
{{-1.,0.,1},RGBColor[.7,0,0]},{{-1.,-1.,1},RGBColor[0,.7,0]},{{0.,-1.,1},RGBColor[0,0,.7]}
};

globe = 
Show[Graphics3D[{EdgeForm[], Sphere[1, 25, 25]}], 
    Boxed -> False, LightSources -> lights,ViewPoint -> {-1,0,0}, SphericalRegion ->True];

globe2 = Show[globe, PolygonIntersections -> False];

Here is how it looks from viewpoints spaced at intervals π/2.

Show[GraphicsArray[Table[Show[globe2,(* SphericalRegion -> True,*)
ViewPoint ->{ Cos[t 2Pi], Sin[t 2Pi], 0},Boxed ->False,
DisplayFunction -> Identity,
Lighting -> False],{t,0,.75,.25}]]];

Coloring and triangulation

gr = 
Show[Graphics3D[{
	EdgeForm[{Thickness[0.02], Hue[0.5]}], 	
	FaceForm[
		{SurfaceColor[Hue[0.17]]}, 
       {SurfaceColor[Hue[0.67, 0.1, 1]]}
    ], 
    Polygon[{{0, 1, 0}, {2, 1, 2}, {0, 1, 2}}], 
    Polygon[{{0, 2, 1}, {0, 0, 1}, {3, 2, 1}}], 
    EdgeForm[Hue[0]], 
    Polygon[{{1, 0, 0}, {3, 1, 0},{3, 2, 1}, 
    	{1, 2, 0}}]}], 
    FaceGrids -> {{-1, 0, 0}, {0, 1, 0}, {0, 0, -1}}, 		Boxed -> False
];

Fix the colors:

gr1=Show[gr, PolygonIntersections->False];

Show[gr1,Lighting -> False];

There are no options in gr1 so the display was boxed and without face grids.
If we look at the other sides of the polygons we see that both  faces are the same color, although the we colored them differently in gr.

Show[gr1,ViewPoint->{2.2, 2.3, -1.3}, Lighting->False];

Check that the side are colored differently in gr (with Lighting->True).

Show[gr,ViewPoint->{2.2, 2.3, -1.3}];

The triangulation of the non-planar quadrilateral show up if we display gr1 with simulated light shows. Notice that the surface color directives have been lost

Show[gr1];

The lines copying the edges of the original polygons can be removed

Show[gr1/._Line-> Sequence[]];

The edges of the triangles can be seen by deleting EdgeForm[]

Show[%/.EdgeForm[] -> Sequence[]];

Change of plot range

The triangulation and addition of lines for the original edges can alter the calculated plot range. Start with

ex1 = Show[Graphics3D[Polygon[{{1, -1, 0}, {1, -1, -1}, 
       {1, 1, -1}, {1, 1, 0}, {0, 0, 0}}]]];

Now use PolygonIntersections -> False:

ex2 = Show[Show[ex1, PolygonIntersections -> False], 
    Lighting -> False];

In this case it is the added lines that made the difference, not the triangulation. Remove the lines

Show[ex2 /. Line[__] -> Sequence[]];

Truncation

Hidden points are discarded; lines and polygons are truncated at the bounding box.

elems ={Polygon[{{0,1,0},{1,1,0},{1,1,1},{0,1,1}}],
Polygon[{{0,0,0},{0,1,0},{0,1,1},{0,0,1}}],
Polygon[{{0,0,0},{1,0,0},{1,0,.6},{0,0,.6}}],
 Thickness[.03], Hue[.5],
Line[{{.03,.5,0},{.03,.5,1}}],
Hue[0],PointSize[.1],
Point[{.4,.5,.2}],Point[{.4,.5,.5}],
Point[{.4,.5,.8}],
Hue[.5],SurfaceColor[Hue[.5]],Cuboid[{.7,.1,0},{.9,.9,1}]};

gr=Show[Graphics3D[elems,
Axes ->True, AxesLabel ->{"x","y", "z"},
ViewPoint->{0,-2, 1.32}]];

Take a snapshot of this with PolygonIntersections -> False with height 0.6 to truncate the objects

gr1= Show[gr,PolygonIntersections-> False,PlotRange->{0,.6}];

Show with original height and exclude out the front polygon to show the truncation and the loss of the lower point because its center was hidden by the front polygon

Show[gr1,
Axes ->True, AxesLabel ->{"x","y", "z"},
PlotRange -> {{0,1},{0.01,1},{0,1}},
ViewPoint -> {0,-2,1.3},
Lighting->False];

One technique is to decide ahead of time what the PlotRange, BoxRatios, ViewPoint, ViewCenter, ViewVertical and SphericalRegion will be  (often, all but the first can be left to take their default values) and then fix the colors of objects subject to these options and combine them.
In doing this you might like to use the following which fixes colors without triangulating or introducing new lines - at least if there are no cuboids.

Avoiding extra lines and triangulation

Programming note: the polygons are color coded to identify which triangles come from their triangulations.

FixColors[gr_Graphics3D]:=
Module[{i=1 ,A,B,gr1 , gr2,gr3, Bs,FFs,pos1,pos2},
	gr1=gr/. {
		p:((FaceForm|SurfaceColor)[__]) ->A[p],
       p:Polygon[_] :> { B[N[i/++i]],p}
};
	Bs= Cases[gr1,_B,Infinity];
	FFs= Bs/.B[n_]:>FaceForm[RGBColor[n,n,n]];(*color coding*)
	pos1 =
	Flatten[Position[gr1,#,Infinity,1]&/@Bs,1];
	gr2=Show[gr1/.{
		A->List,B[x_]->SurfaceColor[RGBColor[x,x,x]]
		}, 
	LightSources->{},
		AmbientLight-> GrayLevel[1],
		Lighting ->True,
		PolygonIntersections->False
 ];
	pos2=Flatten[Position[gr2,#,Infinity,1]&/@FFs,1];
	gr3=Show[gr, PolygonIntersections->False];
	ReplacePart[gr1/.A[x_]->x, gr3, pos1,pos2]
]